home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / sequence.d < prev    next >
Lisp/Scheme  |  1987-06-03  |  9KB  |  491 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     sequence.d
  9.  
  10.     sequence routines
  11. */
  12.  
  13. #include "include.h"
  14.  
  15. #undef endp
  16.  
  17. #define    endp(obje)    ((enum type)((endp_temp = (obje))->d.t) == t_cons ? \
  18.              FALSE : endp_temp == Cnil ? TRUE : \
  19.              (bool)FEwrong_type_argument(Slist, endp_temp))
  20.  
  21. object endp_temp;
  22.  
  23. /*
  24.     I know the following name is not good.
  25. */
  26. object
  27. alloc_simple_vector(l, aet)
  28. int l;
  29. enum aelttype aet;
  30. {
  31.     object x;
  32.  
  33.     x = alloc_object(t_vector);
  34.     x->v.v_hasfillp = FALSE;
  35.     x->v.v_adjustable = FALSE;
  36.     x->v.v_displaced = Cnil;
  37.     x->v.v_dim = x->v.v_fillp = l;
  38.     x->v.v_self = NULL;
  39.     x->v.v_elttype = (short)aet;
  40.     return(x);
  41. }
  42.  
  43. object
  44. alloc_simple_bitvector(l)
  45. int l;
  46. {
  47.     object x;
  48.  
  49.     x = alloc_object(t_bitvector);
  50.     x->bv.bv_hasfillp = FALSE;
  51.     x->bv.bv_adjustable = FALSE;
  52.     x->bv.bv_displaced = Cnil;
  53.     x->bv.bv_dim = x->bv.bv_fillp = l;
  54.     x->bv.bv_offset = 0;
  55.     x->bv.bv_self = NULL;
  56.     return(x);
  57. }
  58.  
  59. Lelt()
  60. {
  61.     check_arg(2);
  62.     vs_base[0] = elt(vs_base[0], fixint(vs_base[1]));
  63.     vs_pop;
  64. }
  65.  
  66. object
  67. elt(seq, index)
  68. object seq;
  69. int index;
  70. {
  71.     int i;
  72.     object l;
  73.  
  74.     if (index < 0) {
  75.         vs_push(make_fixnum(index));
  76.         FEerror("Negative index: ~D.", 1, vs_head);
  77.     }
  78.     switch (type_of(seq)) {
  79.     case t_cons:
  80.         for (i = index, l = seq;  i > 0;  --i)
  81.             if (endp(l))
  82.                 goto E;
  83.             else
  84.                 l = l->c.c_cdr;
  85.         if (endp(l))
  86.             goto E;
  87.         return(l->c.c_car);
  88.  
  89.     case t_vector:
  90.     case t_bitvector:
  91.         if (index >= seq->v.v_fillp)
  92.             goto E;
  93.         return(aref(seq, index));
  94.  
  95.     case t_string:
  96.         if (index >= seq->st.st_fillp)
  97.             goto E;
  98.         return(code_char(seq->ust.ust_self[index]));
  99.  
  100.     default:
  101.         FEerror("~S is not a sequence.", 1, seq);
  102.     }
  103.  
  104. E:
  105.     vs_push(make_fixnum(index));
  106.     FEerror("The index, ~D, is too large", 1, vs_head);
  107. }
  108.  
  109. siLelt_set()
  110. {
  111.     check_arg(3);
  112.     vs_base[0] = elt_set(vs_base[0], fixint(vs_base[1]), vs_base[2]);
  113.     vs_pop;
  114.     vs_pop;
  115. }
  116.  
  117. object
  118. elt_set(seq, index, val)
  119. object seq;
  120. int index;
  121. object val;
  122. {
  123.     int i;
  124.     object l;
  125.  
  126.     if (index < 0) {
  127.         vs_push(make_fixnum(index));
  128.         FEerror("Negative index: ~D.", 1, vs_head);
  129.     }
  130.     switch (type_of(seq)) {
  131.     case t_cons:
  132.         for (i = index, l = seq;  i > 0;  --i)
  133.             if (endp(l))
  134.                 goto E;
  135.             else
  136.                 l = l->c.c_cdr;
  137.         if (endp(l))
  138.             goto E;
  139.         return(l->c.c_car = val);
  140.  
  141.     case t_vector:
  142.     case t_bitvector:
  143.         if (index >= seq->v.v_fillp)
  144.             goto E;
  145.         return(aset(seq, index, val));
  146.  
  147.     case t_string:
  148.         if (index >= seq->st.st_fillp)
  149.             goto E;
  150.         if (type_of(val) != t_character)
  151.             FEerror("~S is not a character.", 1, val);
  152.         seq->st.st_self[index] = val->ch.ch_code;
  153.         return(val);
  154.  
  155.     default:
  156.         FEerror("~S is not a sequence.", 1, seq);
  157.     }
  158.  
  159. E:
  160.     vs_push(make_fixnum(index));
  161.     FEerror("The index, ~D, is too large", 1, vs_head);
  162. }
  163.  
  164. @(defun subseq (sequence start &optional end &aux x)
  165.     int s, e;
  166.     int i, j;
  167. @
  168.     s = fixnnint(start);
  169.     if (end == Cnil)
  170.         e = -1;
  171.     else
  172.         e = fixnnint(end);
  173.     switch (type_of(sequence)) {
  174.     case t_symbol:
  175.         if (sequence == Cnil) {
  176.             if (s > 0)
  177.                 goto ILLEGAL_START_END;
  178.             if (e > 0)
  179.                 goto ILLEGAL_START_END;
  180.             @(return Cnil)
  181.         }
  182.         FEwrong_type_argument(Ssequence, sequence);
  183.  
  184.     case t_cons:
  185.         if (e >= 0)
  186.             if ((e -= s) < 0)
  187.                 goto ILLEGAL_START_END;
  188.         while (s-- > 0) {
  189.             if (type_of(sequence) != t_cons)
  190.                 goto ILLEGAL_START_END;
  191.             sequence = sequence->c.c_cdr;
  192.         }
  193.         if (e < 0)
  194.             @(return `copy_list(sequence)`)
  195.         for (i = 0;  i < e;  i++) {
  196.             if (type_of(sequence) != t_cons)
  197.                 goto ILLEGAL_START_END;
  198.             vs_check_push(sequence->c.c_car);
  199.             sequence = sequence->c.c_cdr;
  200.         }
  201.         vs_push(Cnil);
  202.         while (e-- > 0)
  203.             stack_cons();
  204.         x = vs_pop;
  205.         @(return x)
  206.  
  207.     case t_vector:
  208.         if (s > sequence->v.v_fillp)
  209.             goto ILLEGAL_START_END;
  210.         if (e < 0)
  211.             e = sequence->v.v_fillp;
  212.         else if (e < s || e > sequence->v.v_fillp)
  213.             goto ILLEGAL_START_END;
  214.         x = alloc_simple_vector(e - s, sequence->v.v_elttype);
  215.         array_allocself(x, FALSE);
  216.         switch (sequence->v.v_elttype) {
  217.         case aet_object:
  218.         case aet_fix:
  219.         case aet_sf:
  220.             for (i = s, j = 0;  i < e;  i++, j++)
  221.                 x->v.v_self[j] = sequence->v.v_self[i];
  222.             break;
  223.  
  224.         case aet_lf:
  225.             for (i = s, j = 0;  i < e;  i++, j++)
  226.                 x->lfa.lfa_self[j] =
  227.                 sequence->lfa.lfa_self[i];
  228.             break;
  229.         }
  230.         @(return x)
  231.  
  232.     case t_string:
  233.         if (s > sequence->st.st_fillp)
  234.             goto ILLEGAL_START_END;
  235.         if (e < 0)
  236.             e = sequence->st.st_fillp;
  237.         else if (e < s || e > sequence->st.st_fillp)
  238.             goto ILLEGAL_START_END;
  239.         x = alloc_simple_string(e - s);
  240.         x->st.st_self = alloc_relblock(e - s);
  241.         for (i = s, j = 0;  i < e;  i++, j++)
  242.             x->st.st_self[j] = sequence->st.st_self[i];
  243.         @(return x)
  244.  
  245.     case t_bitvector:
  246.         if (s > sequence->bv.bv_fillp)
  247.             goto ILLEGAL_START_END;
  248.         if (e < 0)
  249.             e = sequence->bv.bv_fillp;
  250.         else if (e < s || e > sequence->bv.bv_fillp)
  251.             goto ILLEGAL_START_END;
  252.         x = alloc_simple_bitvector(e - s);
  253.         x->bv.bv_self = alloc_relblock((e-s+7)/8);
  254.         s += sequence->bv.bv_offset;
  255.         e += sequence->bv.bv_offset;
  256.         for (i = s, j = 0;  i < e;  i++, j++)
  257.             if (sequence->bv.bv_self[i/8]&(0200>>i%8))
  258.                 x->bv.bv_self[j/8]
  259.                 |= 0200>>j%8;
  260.             else
  261.                 x->bv.bv_self[j/8]
  262.                 &= ~(0200>>j%8);
  263.         @(return x)
  264.  
  265.     default:
  266.         FEwrong_type_argument(Ssequence, vs_base[0]);
  267.     }
  268.  
  269. ILLEGAL_START_END:
  270.     FEerror("~S and ~S are illegal as :START and :END~%\
  271. for the sequence ~S.", 3, start, end, sequence);
  272. @)
  273.  
  274. Lcopy_seq()
  275. {
  276.     check_arg(1);
  277.     vs_push(small_fixnum(0));
  278.     Lsubseq();
  279. }
  280.  
  281. int
  282. length(x)
  283. object x;
  284. {
  285.     int i;
  286.  
  287.     switch (type_of(x)) {
  288.     case t_symbol:
  289.         if (x == Cnil)
  290.             return(0);
  291.         FEwrong_type_argument(Ssequence, x);
  292.  
  293.     case t_cons:
  294.         for (i = 0;  !endp(x);  i++, x = x->c.c_cdr)
  295.             ;
  296.         return(i);
  297.  
  298.     case t_vector:
  299.     case t_string:
  300.     case t_bitvector:
  301.         return(x->v.v_fillp);
  302.  
  303.     default:
  304.         FEwrong_type_argument(Ssequence, x);
  305.     }
  306. }
  307.  
  308. Llength()
  309. {
  310.     check_arg(1);
  311.     vs_base[0] = make_fixnum(length(vs_base[0]));
  312. }
  313.  
  314. Lreverse()
  315. {
  316.     check_arg(1);
  317.     vs_base[0] = reverse(vs_base[0]);
  318. }
  319.  
  320. object
  321. reverse(seq)
  322. object seq;
  323. {
  324.     object x, y, *v;
  325.     int i, j, k;
  326.  
  327.     switch (type_of(seq)) {
  328.     case t_symbol:
  329.         if (seq == Cnil)
  330.             return(Cnil);
  331.         FEwrong_type_argument(Ssequence, seq);
  332.  
  333.     case t_cons:
  334.         v = vs_top;
  335.         vs_push(Cnil);
  336.         for (x = seq;  !endp(x);  x = x->c.c_cdr)
  337.             *v = make_cons(x->c.c_car, *v);
  338.         return(vs_pop);
  339.  
  340.     case t_vector:
  341.         x = seq;
  342.         k = x->v.v_fillp;
  343.         y = alloc_simple_vector(k, x->v.v_elttype);
  344.         vs_push(y);
  345.         array_allocself(y, FALSE);
  346.         switch (x->v.v_elttype) {
  347.         case aet_object:
  348.         case aet_fix:
  349.         case aet_sf:
  350.             for (j = k - 1, i = 0;  j >=0;  --j, i++)
  351.                 y->v.v_self[j] = x->v.v_self[i];
  352.             break;
  353.  
  354.         case aet_lf:
  355.             for (j = k - 1, i = 0;  j >=0;  --j, i++)
  356.                 y->lfa.lfa_self[j] = x->lfa.lfa_self[i];
  357.             break;
  358.         }
  359.         return(vs_pop);
  360.  
  361.     case t_string:
  362.         x = seq;
  363.         y = alloc_simple_string(x->st.st_fillp);
  364.         vs_push(y);
  365.         y->st.st_self
  366.         = alloc_relblock(x->st.st_fillp);
  367.         for (j = x->st.st_fillp - 1, i = 0;  j >=0;  --j, i++)
  368.             y->st.st_self[j] = x->st.st_self[i];
  369.         return(vs_pop);
  370.  
  371.     case t_bitvector:
  372.         x = seq;
  373.         y = alloc_simple_bitvector(x->bv.bv_fillp);
  374.         vs_push(y);
  375.         y->bv.bv_self
  376.         = alloc_relblock((x->bv.bv_fillp+7)/8);
  377.         for (j = x->bv.bv_fillp - 1, i = x->bv.bv_offset;
  378.              j >=0;
  379.              --j, i++)
  380.             if (x->bv.bv_self[i/8]&(0200>>i%8))
  381.                 y->bv.bv_self[j/8] |= 0200>>j%8;
  382.             else
  383.                 y->bv.bv_self[j/8] &= ~(0200>>j%8);
  384.         return(vs_pop);
  385.  
  386.     default:
  387.         FEwrong_type_argument(Ssequence, seq);
  388.     }
  389. }
  390.  
  391. Lnreverse()
  392. {
  393.     check_arg(1);
  394.     vs_base[0] = nreverse(vs_base[0]);
  395. }
  396.  
  397. object
  398. nreverse(seq)
  399. object seq;
  400. {
  401.     object x, y, z;
  402.     int i, j, k;
  403.  
  404.     switch (type_of(seq)) {
  405.     case t_symbol:
  406.         if (seq == Cnil)
  407.             return(Cnil);
  408.         FEwrong_type_argument(Ssequence, seq);
  409.  
  410.     case t_cons:
  411.         for (x = Cnil, y = seq;  !endp(y->c.c_cdr);) {
  412.             z = y;
  413.             y = y->c.c_cdr;
  414.             z->c.c_cdr = x;
  415.             x = z;
  416.         }
  417.         y->c.c_cdr = x;
  418.         return(y);
  419.  
  420.     case t_vector:
  421.         x = seq;
  422.         k = x->v.v_fillp;
  423.         switch (x->v.v_elttype) {
  424.         case aet_object:
  425.         case aet_fix:
  426.         case aet_sf:
  427.             for (i = 0, j = k - 1;  i < j;  i++, --j) {
  428.                 y = x->v.v_self[i];
  429.                 x->v.v_self[i] = x->v.v_self[j];
  430.                 x->v.v_self[j] = y;
  431.             }
  432.             return(seq);
  433.  
  434.         case aet_lf:
  435.             for (i = 0, j = k - 1;  i < j;  i++, --j) {
  436.                 longfloat y;
  437.                 y = x->lfa.lfa_self[i];
  438.                 x->lfa.lfa_self[i] = x->lfa.lfa_self[j];
  439.                 x->lfa.lfa_self[j] = y;
  440.             }
  441.             return(seq);
  442.         }
  443.  
  444.     case t_string:
  445.         x = seq;
  446.         for (i = 0, j = x->st.st_fillp - 1;  i < j;  i++, --j) {
  447.             k = x->st.st_self[i];
  448.             x->st.st_self[i] = x->st.st_self[j];
  449.             x->st.st_self[j] = k;
  450.         }
  451.         return(seq);
  452.  
  453.     case t_bitvector:
  454.         x = seq;
  455.         for (i = x->bv.bv_offset,
  456.              j = x->bv.bv_fillp + x->bv.bv_offset - 1;
  457.              i < j;
  458.              i++, --j) {
  459.             k = x->bv.bv_self[i/8]&(0200>>i%8);
  460.             if (x->bv.bv_self[j/8]&(0200>>j%8))
  461.                 x->bv.bv_self[i/8]
  462.                 |= 0200>>i%8;
  463.             else
  464.                 x->bv.bv_self[i/8]
  465.                 &= ~(0200>>i%8);
  466.             if (k)
  467.                 x->bv.bv_self[j/8]
  468.                 |= 0200>>j%8;
  469.             else
  470.                 x->bv.bv_self[j/8]
  471.                 &= ~(0200>>j%8);
  472.         }
  473.         return(seq);
  474.  
  475.     default:
  476.         FEwrong_type_argument(Ssequence, seq);
  477.     }
  478. }
  479.  
  480.  
  481. init_sequence_function()
  482. {
  483.     make_function("ELT", Lelt);
  484.     make_si_function("ELT-SET", siLelt_set);
  485.     make_function("SUBSEQ", Lsubseq);
  486.     make_function("COPY-SEQ", Lcopy_seq);
  487.     make_function("LENGTH", Llength);
  488.     make_function("REVERSE", Lreverse);
  489.     make_function("NREVERSE", Lnreverse);
  490. }
  491.